home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / examples / callbacks.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-05  |  3.5 KB  |  106 lines
  1. ; -*-Lisp-*-
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;
  4. ; File:         callbacks.lsp
  5. ; RCS:          $Header: callbacks.lsp,v 1.4 91/10/05 14:44:10 mayer Exp $
  6. ; Description:  Demonstration of using callbacks and timeouts.
  7. ; Author:       Niels Mayer, HPLabs
  8. ; Created:      Sat Nov 25 01:01:08 1989
  9. ; Modified:     Sat Oct  5 14:43:48 1991 (Niels Mayer) mayer@hplnpm
  10. ; Language:     Lisp
  11. ; Package:      N/A
  12. ; Status:       X11r5 contrib tape release
  13. ;
  14. ; WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. ; XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. ;
  17. ; Permission to use, copy, modify, distribute, and sell this software and its
  18. ; documentation for any purpose is hereby granted without fee, provided that
  19. ; the above copyright notice appear in all copies and that both that
  20. ; copyright notice and this permission notice appear in supporting
  21. ; documentation, and that the name of Hewlett-Packard and Niels Mayer not be
  22. ; used in advertising or publicity pertaining to distribution of the software
  23. ; without specific, written prior permission.  Hewlett-Packard and Niels Mayer
  24. ; makes no representations about the suitability of this software for any
  25. ; purpose.  It is provided "as is" without express or implied warranty.
  26. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  27.  
  28. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  29. ;TEST CALLBACKS AND TIMEOUTS
  30. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  31.  
  32. (defun get-date ()
  33.   (let*
  34.       ((pipe (popen "date" "r"))
  35.        (str (read-line pipe))
  36.        )
  37.     (pclose pipe)
  38.     str))
  39.  
  40. (defun make-rc-shell ()
  41.   (setq top_w
  42.     (send TOP_LEVEL_SHELL_WIDGET_CLASS :new 
  43.           :XMN_GEOMETRY "500x500+0+0"
  44.           :XMN_TITLE (get-date)
  45.           :XMN_ICON_NAME "win-test"
  46.           ))
  47.   (setq rc_w
  48.     (send XM_ROW_COLUMN_WIDGET_CLASS :new :managed top_w
  49.           :XMN_ADJUST_LAST nil
  50.           ))
  51.   (send top_w :realize)
  52.   )
  53.  
  54. (make-rc-shell)
  55.  
  56. (setq start_but_w 
  57.       (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed 
  58.         "start" rc_w 
  59. ;;;        :XMN_FOREGROUND "green"
  60. ;;;        :XMN_BACKGROUND "black"
  61.         ))
  62.  
  63. (send start_but_w :has_callbacks :XMN_ARM_CALLBACK)
  64. (send start_but_w :has_callbacks :XMN_DISARM_CALLBACK)
  65. (send start_but_w :has_callbacks :XMN_ACTIVATE_CALLBACK)
  66.  
  67. (send start_but_w :set_callback :XMN_ACTIVATE_CALLBACK '()
  68.       `((setq to 
  69.           (xt_add_timeout
  70.            1000 
  71.            '((send ,XM_PUSH_BUTTON_WIDGET_CLASS :new :managed 
  72.                (get-date) ,rc_w
  73. ;;;               :XMN_BACKGROUND "magenta"
  74.                )
  75.          (setq to (xt_add_timeout 1000 TIMEOUT_OBJ))
  76.          )
  77.            ))
  78.     ))
  79.  
  80.  
  81. (send start_but_w :has_callbacks :XMN_ARM_CALLBACK)
  82. (send start_but_w :has_callbacks :XMN_DISARM_CALLBACK)
  83. (send start_but_w :has_callbacks :XMN_ACTIVATE_CALLBACK)
  84.  
  85. (setq stop_but_w 
  86.       (send XM_PUSH_BUTTON_WIDGET_CLASS :new :managed 
  87.         "stop" rc_w 
  88. ;;;        :XMN_FOREGROUND "red"
  89. ;;;        :XMN_BACKGROUND "black"
  90.         ))
  91.  
  92. (send stop_but_w :has_callbacks :XMN_ARM_CALLBACK)
  93. (send stop_but_w :has_callbacks :XMN_DISARM_CALLBACK)
  94. (send stop_but_w :has_callbacks :XMN_ACTIVATE_CALLBACK)
  95.  
  96. (send stop_but_w :set_callback :XMN_ACTIVATE_CALLBACK '()
  97.       '(
  98.     (xt_remove_timeout to)
  99.     (format t "quack\n")
  100.     ))
  101.  
  102. (send stop_but_w :has_callbacks :XMN_ARM_CALLBACK) ;==>CALLBACK_HAS_NONE
  103. (send stop_but_w :has_callbacks :XMN_DISARM_CALLBACK) ;==>CALLBACK_HAS_NONE
  104. (send stop_but_w :has_callbacks :XMN_ACTIVATE_CALLBACK)    ;==>CALLBACK_HAS_SOME
  105. (send stop_but_w :has_callbacks :XMN_APPLY_CALLBACK) ;==>CALLBACK_NO_LIST
  106.